Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-20/nrd34.zip/SCREEN.PAS

Pascal/Delphi Source File | 1990-12-01 | 16KB | 624 lines

{SCREEN.PAS --- rev 2.4
       Author:  Tom Whiteside
                11505 Oak View Dr
                Austin, TX 78759
                [phone]


       Purpose: Various screen control, data entry utilities.  These were
                developed years ago for Apple Pascal and subsequently ported
                to IBM Pascal then Turbo Pascal to migrate other code along.
                Their main asset is their use by many lines of code and my
                familiarity with them. }
{$I-}
{$V-}
unit screen;

interface

  type
    crtcmd    = (ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT);

    keycmd    = packed record
            charperline,
            linesperscreen:byte;
            upkey,
            downkey,
            fskey,
            bskey,
            rubkey,
            inskey,
            delkey,
            pgupkey,
            pgdnkey,
            homekey,
            endkey,
            esckey,
                    backtabkey,
                    tabkey,
                    ctrlpgupkey,
                    ctrlpgdnkey:char;
          end;

    speakerbeep = (SILENT,BEEP);

    scrn_attr    = (UNDERSCORE,BLINK,BROWN,LIGHTGRAY,DARKGRAY,BLACK,
           RED,LIGHTBLUE,LIGHTGREEN,LIGHTCYAN,LIGHTRED,LIGHTMAGENTA,
           GREEN,YELLOW,BLUE,MAGENTA,CYAN,WHITE);

    scrn_mode    = (FOREGROUND,BACKGROUND);

    lstring    = string[255];

  const keyinfo : keycmd =
             (charperline:      80;
              linesperscreen: 25;
              upkey:      chr(15);
              downkey:      chr(11);
              fskey:      chr(21);
              bskey:      chr(7);
              rubkey:      chr(8);
              inskey:      chr(1);
              delkey:      chr(2);
              pgupkey:      chr(3);
              pgdnkey:      chr(4);
              homekey:      chr(5);
              endkey:      chr(6);
              esckey:      chr(27);
                          backtabkey:     chr(10);
                          tabkey:         chr(9);
                          ctrlpgupkey:    chr(14);
                          ctrlpgdnkey:    chr(16));

  procedure call_crt(cmd:crtcmd); { this was crt in the IBM Pascal vers }
  procedure home;
  procedure gotoxy_old(x,y:integer); { change this in source from gotoxy }
  function  fetch:char;
  procedure bell;
  procedure entnum(x,y:integer; var val:integer; var ok,nullval:boolean;
               message:lstring);
  procedure prompt(promptln:lstring; var rtncmd:char; ring:speakerbeep;
               defrec:integer);
  procedure hndlerr(abor:boolean; var escape:char; rslt:integer);
  function  keypress:boolean;
  procedure writea(attr:scrn_attr; mode:scrn_mode);
  procedure show_line(x,y,fieldlen:integer; val:lstring; edit:boolean);
  procedure editfield(x,y,fieldlen:integer; number:boolean; var val:lstring);

implementation


  uses crt,strutil,intutil;


  const CARRET = chr(13);  {carriage return}

  type monitortype = (BW_MON,COLOR_MON);

  var  monitor: monitortype;
       screenbuf: text;


  procedure call_crt;
  var j,k,x,y,lines,chars:integer;
  begin { call_crt }
    x:=wherex; y:=wherey;
    lines:=ord(keyinfo.linesperscreen);
    chars:=ord(keyinfo.charperline);
    case cmd of
      UP:    gotoxy(x, maxi(1,y - 1));
      DOWN:    gotoxy(x, mini(lines,y + 1));
      RIGHT:    gotoxy(mini(chars,x + 1), y);
      LEFT:    gotoxy(maxi(1,x - 1), y);
      ERASEOL:    clreol;
      ERASEOS:    begin
          k:=x;
          { erase from cursor position down }
          for j:=y to lines do
            begin
              gotoxy(k,j);
              call_crt(ERASEOL);
              k:=0; { reset "x" place holder after 1rst line }
            end;
          gotoxy(x,y);
        end;
    end; { cases }
  end; { call_crt }


  procedure home;
  begin
    clrscr;
  end;

  procedure gotoxy_old; { IBM Pascal had upper left at 0,0 }
  begin
    gotoxy(x + 1,y + 1);
  end;

  function fetch;
  var ch:char;
  begin
    ch:=readkey;
    if ord(ch) = 0 then { fetch extended function }
      begin
    ch:=readkey;
    case ord(ch) of
      71:ch:=keyinfo.homekey;
      72:ch:=keyinfo.upkey;
      73:ch:=keyinfo.pgupkey;
      75:ch:=keyinfo.bskey;
      77:ch:=keyinfo.fskey;
      79:ch:=keyinfo.endkey;
      80:ch:=keyinfo.downkey;
      81:ch:=keyinfo.pgdnkey;
      82:ch:=keyinfo.inskey;
      83:ch:=keyinfo.delkey;
          15:ch:=keyinfo.backtabkey;
         118:ch:=keyinfo.ctrlpgdnkey;
         132:ch:=keyinfo.ctrlpgupkey;
    else ch:=chr(0);
    end;
      end;
    fetch:=ch;
  end;

  procedure bell;
  begin
    write(chr(7));
  end;


  function keypress;
  { mapped for compatibility }
  begin
    keypress:=keypressed;
  end;

  procedure prompt;
  begin
    gotoxy(1,1); clreol;
    if ring = BEEP then { beep and flush key buffer }
      begin
    writea(LIGHTRED,FOREGROUND);
    bell;
    while keypress do rtncmd:=fetch;
      end
    else
      begin
    writea(LIGHTGREEN,FOREGROUND);
      end;
    write(promptln);
    if defrec > 0 then write(' [',defrec:0,']');
    gotoxy(ord(keyinfo.charperline) + 1,1);
    rtncmd:=fetch;
    if (rtncmd in ['a'..'z']) then { capitalize }
       rtncmd:=chr(ord(rtncmd) + ord('A') - ord('a'));
    writea(LIGHTGRAY,FOREGROUND);
  end;

  procedure hndlerr;

    procedure ems(rslt:integer; t:lstring);
    begin
      call_crt(ERASEOS);
      writeln; bell;
      writea(LIGHTRED,FOREGROUND);
      writeln('Error #',rslt:4,' ',t);
      writea(LIGHTGRAY,FOREGROUND);
      writeln;
      write('Type <SPACE> to continue');
      if not abor then write(' <ESC> to cancel command');
      escape:=fetch;
      writeln;
      if (escape in ['a'..'z']) then { capitalize }
    escape:=chr(ord(escape) + ord('A') - ord('a'));
    end; { ems }

  begin { hndlerr }
    case rslt of
       0:;   { no error }
     1:  ems(rslt,'Invalid function Error');
     2:  ems(rslt,'File not found');
     3:  ems(rslt,'Path not found');
     4:  ems(rslt,'Too many open files');
     5:  ems(rslt,'File access denied');
     6:  ems(rslt,'Invalid file handle');
    12:  ems(rslt,'Invalid file access code');
    15:  ems(rslt,'Invalid drive number');
    16:  ems(rslt,'Cannot remove current directory');
    17:  ems(rslt,'Cannot rename across drives');
       100:  ems(rslt,'Disk Error');
       101:  ems(rslt,'Disk Write Error');
       102:  ems(rslt,'File not assigned');
       103:  ems(rslt,'File not open');
       104:  ems(rslt,'File not open for input');
       105:  ems(rslt,'File not open for output');
       106:  ems(rslt,'Invalid numeric format');
       150:  ems(rslt,'Disk is write protected');
       151:  ems(rslt,'Unknown unit');
       152:  ems(rslt,'Drive not ready');
       153:  ems(rslt,'Unknown command');
       154:  ems(rslt,'CRC error in data');
       155:  ems(rslt,'Bad drive request structure length');
       156:  ems(rslt,'Disk seek error');
       157:  ems(rslt,'Unknown media type');
       158:  ems(rslt,'Sector not found');
       159:  ems(rslt,'Printer out of paper');
       160:  ems(rslt,'Device write fault');
       161:  ems(rslt,'Device read fault');
       162:  ems(rslt,'Hardware failure');
       else  ems(rslt,'Undefined error');
    end; { cases }
  end;    { hndlerr }


  procedure writea;
  var i:integer;
  begin
    case monitor of
      COLOR_MON:
     case mode of
        FOREGROUND:
          begin
        case attr of
          BLINK       :textcolor(textattr+128);
          BLACK       :textcolor(0);
          BROWN       :textcolor(6);
          LIGHTGRAY   :textcolor(7);
          DARKGRAY    :textcolor(8);
          LIGHTBLUE   :textcolor(9);
          LIGHTGREEN  :textcolor(10);
          LIGHTCYAN   :textcolor(11);
          LIGHTRED    :textcolor(12);
          LIGHTMAGENTA:textcolor(13);
          RED          :textcolor(4);
          GREEN       :textcolor(2);
          YELLOW      :textcolor(14);
          BLUE          :textcolor(1);
          MAGENTA     :textcolor(5);
          CYAN          :textcolor(3);
          WHITE       :textcolor(15);
        end; { cases }
          end;
        BACKGROUND:
          begin
        case attr of
          BLACK      :textbackground(0);
          RED         :textbackground(4);
          GREEN      :textbackground(2);
          YELLOW     :textbackground(6); { brown }
          BLUE         :textbackground(1);
          MAGENTA    :textbackground(5);
          CYAN         :textbackground(3);
          WHITE      :textbackground(7); { grey }
        end; { cases }
          end;
    end;
      BW_MON:
     case mode of
        FOREGROUND:
          begin
        case attr of
          BLINK      :textcolor(textattr+128);
          BLACK      :textcolor(0);
          WHITE      :textcolor(15);
        end; { cases }
          end;
        BACKGROUND:
          begin
        case attr of
          BLACK      :textbackground(0);
          WHITE      :textbackground(7); { grey }
        end; { cases }
          end;
     end;
       end;
  end;


  procedure show_line;
  var i:integer;
      lf_bracket,rt_bracket:char;
  begin { show_line }
    gotoxy(x,y + 1); call_crt(ERASEOL);
    if edit then { they are editing this line }
      begin
    lf_bracket:='[';
    rt_bracket:=']';
    writea(BLUE,BACKGROUND);
    writea(YELLOW,FOREGROUND);
      end
    else
      begin
    writea(BLACK,BACKGROUND);
    writea(LIGHTGRAY,FOREGROUND);
    lf_bracket:=' ';
    rt_bracket:=' ';
      end;
    write(lf_bracket,val);
    gotoxy(x + 1 + fieldlen,y + 1);
    write(rt_bracket);
  end;    { show_line }


  procedure edfield(x,y,fieldlen:integer; number:boolean; var val:lstring;
             var ok:boolean);

  { parameters: x,y     = cursor position
        fieldlen = allowable length for field
        number     = flag that if true restricts the keys usable
        val     = return string
        ok     = TRUE if the user did not hit escape    }

  var ptr,i:integer;
      ch:char;
      errflg,flag,insert_mode:boolean;
      oldval:string[255];


    procedure errmsg(message:lstring);
    var ch:char;
    begin
      errflg:=TRUE;
      bell;
      while keypress do ch:=fetch; { flush keyboard buffer }
      writea(LIGHTGRAY,FOREGROUND);
      show_line(x,y,fieldlen,val,TRUE); { re-display line }
      gotoxy(x + fieldlen + 6,y + 1);
      writea(RED,FOREGROUND);
      write(message);
      writea(BLUE,BACKGROUND);
      writea(YELLOW,FOREGROUND);
      gotoxy(x + 1 + ptr,y + 1);
    end;

    procedure clrerr(var errflg:boolean) ;
    { erase error message at the right of screen }
    begin
      if errflg then
    begin
      errflg:=FALSE;
      writea(LIGHTGRAY,FOREGROUND);
      writea(BLACK,BACKGROUND);
      gotoxy(x + fieldlen + 5,y + 1);  call_crt(ERASEOL);
      gotoxy(x + 1 + ptr,y + 1);
      writea(BLUE,BACKGROUND);
      writea(YELLOW,FOREGROUND);
    end;
    end;

    procedure blankfill(fieldlen:integer; var val:lstring);
    begin
      while length(val) < fieldlen do val:=concat(val,' ');
    end;


    procedure get_normal;

    { fetch normal character and display it.  Handle field overflow and
      insert_mode }

    var i:integer;
    s:string[1];
    begin
      if ptr < fieldlen
    then
      begin
        if ((number) and (ch in ['0'..'9',' ','.']))
        or ((ptr = 0) and (ch = '-')) or not number then
          begin { all's well }
        if not insert_mode then
          begin
            write(ch); { echo character to screen }
            ptr:=ptr + 1;
            val[ptr]:=ch
          end
        else { handle insert mode }
          begin
            ptr:=ptr + 1;
            for i:=fieldlen downto ptr do val[i]:=val[i - 1];
            val[ptr]:=ch;
            for i:=ptr to fieldlen do write(val[i]);
            gotoxy(x + ptr + 1,y + 1);
          end
          end
        else errmsg('Key not a number')
      end
    else errmsg('Max characters entered')
    end; { get_normal }

    procedure do_backspace;
    begin
      if ptr > 0 then { it's ok to backspace }
    begin
      ptr:=ptr - 1;
      gotoxy(x + ptr + 1,y + 1)
    end
      else errmsg('Please stay right of ''[''')
    end;

    procedure do_forwardspace;
    begin
      if ptr < fieldlen then { its ok to forward space }
    begin
      ptr:=ptr + 1;
      gotoxy(x + ptr + 1,y + 1)
    end
      else errmsg('Please stay left of '']''')
    end;

    procedure do_del;
    var i:integer;
    begin
      for i:=ptr + 1 to fieldlen - 1 do val[i]:=val[i + 1];
      val[fieldlen]:=' ';
      for i:=ptr + 1 to fieldlen do write(val[i]);
      gotoxy(x + ptr + 1,y + 1);
    end;

    procedure do_rub;
    var i:integer;
    begin
      if ptr > 0 then ptr:=ptr - 1;
      gotoxy(x + ptr + 1,y + 1);
      do_del;
    end;

    procedure toggle_insert;
    begin
      insert_mode:=not insert_mode;
      writea(LIGHTGRAY,FOREGROUND);
      gotoxy(31,25);
      if insert_mode then
    begin
      writea(RED,FOREGROUND);
      write('Insert');
    end
      else call_crt(ERASEOL);
      gotoxy(x + 1 + ptr,y + 1);
      writea(BLUE,BACKGROUND);
      writea(YELLOW,FOREGROUND);
   end;

   procedure do_esc;
   begin
     val:=oldval;
     ok:=FALSE;
   end;

   procedure do_home;
   begin
     ptr:=0;
     gotoxy(x + ptr + 1,y + 1)
   end;

   procedure do_end;
   begin
     ptr:=fieldlen;
     while (ptr > 0) and (val[ptr] = ' ') do
       ptr:=ptr - 1;
     gotoxy(x + ptr + 1,y + 1)
   end;

  begin { edfield }
    insert_mode:=FALSE;
    ok:=TRUE;
    if number and (val = '-0.00') then val:='0.00';
    oldval:=val; { save copy in case they abort }
    blankfill(fieldlen,val);
    ptr:=0;
    show_line(x,y,fieldlen,val,TRUE);
    gotoxy(x + 1,y + 1);
    repeat
      ch:=fetch;
      clrerr(errflg);
      if (ch <> CARRET) and (ord(ch) >= ord(' ')) then get_normal
      else if ch = keyinfo.bskey   then do_backspace
      else if ch = keyinfo.fskey   then do_forwardspace
      else if ch = keyinfo.delkey  then do_del
      else if ch = keyinfo.rubkey  then do_rub
      else if ch = keyinfo.inskey  then toggle_insert
      else if ch = keyinfo.esckey  then do_esc
      else if ch = keyinfo.homekey then do_home
      else if ch = keyinfo.endkey  then do_end
      else if ch <> CARRET       then errmsg('Invalid Character');
    until (ch = CARRET) or (ch = keyinfo.esckey);

    if number then { strip off trailing blanks }
      begin
    ptr:=length(val);
    flag:=TRUE;
    while (ptr > 0) and flag do
      begin
        flag:=val[ptr] = ' ';
        if flag then delete(val,ptr,1);
        ptr:=ptr - 1;
      end;
      end;
    writea(LIGHTGRAY,FOREGROUND);
    writea(BLACK,BACKGROUND);
    gotoxy(1,25); call_crt(ERASEOL);
    show_line(x,y,fieldlen,val,FALSE);
  end; { edfield }


  procedure editfield;
  var dummy:boolean;
  begin
    { normal editfield but ignore dummy (TRUE if user hit ESC) }
    edfield(x,y,fieldlen,number,val,dummy);
  end;

  procedure entnum;
  var s1,s2:lstring;
      s3:string[255];
      i,j:integer;
      bogus:boolean;
  begin
    s1:=''; ok:=TRUE;
    bogus:=TRUE;  { Guilty until proven innocent }
    s3:=concat('Enter ',message,' number <ESC> quits: ');
    gotoxy(x + 1,y + 1); call_crt(ERASEOL);
    writea(LIGHTGREEN,FOREGROUND);
    write(s3);
    while bogus do
      begin
    bogus:=FALSE;
    edfield(x + length(s3),y,5,TRUE,s1,ok);
    j:=1;
    val:=0;
    nullval:=(s1 = '');
    if not nullval and ok then for i:=length(s1) downto 1 do
      begin
        if not (s1[i] in ['-','0'..'9']) then bogus:=TRUE
        else
          begin
        if s1[i] = '-' then val:=-val
        else
          begin
            val:=val + (ord(s1[i]) - ord('0')) * j;
            j:=j * 10
          end
          end
      end
      end
  end;

  procedure initcrtinfo; { find out whether user has a BW or color monitor }
  var f:text;
      ch:char;
      err:word;

  begin
    monitor:=BW_MON;
    assign(f,'@MONITOR.DAT');
    reset(f);  { expect a file not found error }
    err:=ioresult;
    if err = 0 then
      begin
    read(f,ch); { read color attribute }
    close(f);
      end
    else { ok to write the result }
      begin
    close(f);
    rewrite(f);
    err:=ioresult;
    home;
    prompt('To use color in this program, type ''C'' otherwise hit ENTER'
          ,ch,SILENT,0);
    write(f,ch);
    err:=ioresult; hndlerr(TRUE,ch,err);
    close(f);
    err:=ioresult; hndlerr(TRUE,ch,err);
      end;
      if ch = 'C' then monitor:=COLOR_MON;
    assigncrt(screenbuf);
  end;


begin { screen }
  initcrtinfo
end.